home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / fortran / f2c_src.zip / F2C / GRAM.DCL < prev    next >
Text File  |  1991-06-10  |  8KB  |  396 lines
  1. spec:      dcl
  2.     | common
  3.     | external
  4.     | intrinsic
  5.     | equivalence
  6.     | data
  7.     | implicit
  8.     | namelist
  9.     | SSAVE
  10.         { NO66("SAVE statement");
  11.           saveall = YES; }
  12.     | SSAVE savelist
  13.         { NO66("SAVE statement"); }
  14.     | SFORMAT
  15.         { fmtstmt(thislabel); setfmt(thislabel); }
  16.     | SPARAM in_dcl SLPAR paramlist SRPAR
  17.         { NO66("PARAMETER statement"); }
  18.     ;
  19.  
  20. dcl:      type opt_comma name in_dcl new_dcl dims lengspec
  21.         { settype($3, $1, $7);
  22.           if(ndim>0) setbound($3,ndim,dims);
  23.         }
  24.     | dcl SCOMMA name dims lengspec
  25.         { settype($3, $1, $5);
  26.           if(ndim>0) setbound($3,ndim,dims);
  27.         }
  28.     | dcl SSLASHD datainit vallist SSLASHD
  29.         { if (new_dcl == 2) {
  30.             err("attempt to give DATA in type-declaration");
  31.             new_dcl = 1;
  32.             }
  33.         }
  34.     ;
  35.  
  36. new_dcl:    { new_dcl = 2; }
  37.  
  38. type:      typespec lengspec
  39.         { varleng = $2;
  40.           if (vartype == TYLOGICAL && varleng == 1) {
  41.             varleng = 0;
  42.             err("treating LOGICAL*1 as LOGICAL");
  43.             --nerr;    /* allow generation of .c file */
  44.             }
  45.         }
  46.     ;
  47.  
  48. typespec:  typename
  49.         { varleng = ($1<0 || $1==TYLONG ? 0 : typesize[$1]);
  50.           vartype = $1; }
  51.     ;
  52.  
  53. typename:    SINTEGER    { $$ = TYLONG; }
  54.     | SREAL        { $$ = tyreal; }
  55.     | SCOMPLEX    { ++complex_seen; $$ = TYCOMPLEX; }
  56.     | SDOUBLE    { $$ = TYDREAL; }
  57.     | SDCOMPLEX    { ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); $$ = TYDCOMPLEX; }
  58.     | SLOGICAL    { $$ = TYLOGICAL; }
  59.     | SCHARACTER    { NO66("CHARACTER statement"); $$ = TYCHAR; }
  60.     | SUNDEFINED    { $$ = TYUNKNOWN; }
  61.     | SDIMENSION    { $$ = TYUNKNOWN; }
  62.     | SAUTOMATIC    { NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; }
  63.     | SSTATIC    { NOEXT("STATIC statement"); $$ = - STGBSS; }
  64.     ;
  65.  
  66. lengspec:
  67.         { $$ = varleng; }
  68.     | SSTAR intonlyon expr intonlyoff
  69.         {
  70.         expptr p;
  71.         p = $3;
  72.         NO66("length specification *n");
  73.         if( ! ISICON(p) || p->constblock.Const.ci <= 0 )
  74.             {
  75.             $$ = 0;
  76.             dclerr("length must be a positive integer constant",
  77.                 NPNULL);
  78.             }
  79.         else {
  80.             if (vartype == TYCHAR)
  81.                 $$ = p->constblock.Const.ci;
  82.             else switch((int)p->constblock.Const.ci) {
  83.                 case 1:    $$ = 1; break;
  84.                 case 2: $$ = typesize[TYSHORT];    break;
  85.                 case 4: $$ = typesize[TYLONG];    break;
  86.                 case 8: $$ = typesize[TYDREAL];    break;
  87.                 case 16: $$ = typesize[TYDCOMPLEX]; break;
  88.                 default:
  89.                     dclerr("invalid length",NPNULL);
  90.                     $$ = varleng;
  91.                 }
  92.             }
  93.         }
  94.     | SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff
  95.         { NO66("length specification *(*)"); $$ = -1; }
  96.     ;
  97.  
  98. common:      SCOMMON in_dcl var
  99.         { incomm( $$ = comblock("") , $3 ); }
  100.     | SCOMMON in_dcl comblock var
  101.         { $$ = $3;  incomm($3, $4); }
  102.     | common opt_comma comblock opt_comma var
  103.         { $$ = $3;  incomm($3, $5); }
  104.     | common SCOMMA var
  105.         { incomm($1, $3); }
  106.     ;
  107.  
  108. comblock:  SCONCAT
  109.         { $$ = comblock(""); }
  110.     | SSLASH SNAME SSLASH
  111.         { $$ = comblock(token); }
  112.     ;
  113.  
  114. external: SEXTERNAL in_dcl name
  115.         { setext($3); }
  116.     | external SCOMMA name
  117.         { setext($3); }
  118.     ;
  119.  
  120. intrinsic:  SINTRINSIC in_dcl name
  121.         { NO66("INTRINSIC statement"); setintr($3); }
  122.     | intrinsic SCOMMA name
  123.         { setintr($3); }
  124.     ;
  125.  
  126. equivalence:  SEQUIV in_dcl equivset
  127.     | equivalence SCOMMA equivset
  128.     ;
  129.  
  130. equivset:  SLPAR equivlist SRPAR
  131.         {
  132.         struct Equivblock *p;
  133.         if(nequiv >= maxequiv)
  134.             many("equivalences", 'q', maxequiv);
  135.         p  =  & eqvclass[nequiv++];
  136.         p->eqvinit = NO;
  137.         p->eqvbottom = 0;
  138.         p->eqvtop = 0;
  139.         p->equivs = $2;
  140.         }
  141.     ;
  142.  
  143. equivlist:  lhs
  144.         { $$=ALLOC(Eqvchain);
  145.           $$->eqvitem.eqvlhs = (struct Primblock *)$1;
  146.         }
  147.     | equivlist SCOMMA lhs
  148.         { $$=ALLOC(Eqvchain);
  149.           $$->eqvitem.eqvlhs = (struct Primblock *) $3;
  150.           $$->eqvnextp = $1;
  151.         }
  152.     ;
  153.  
  154. data:      SDATA in_data datalist
  155.     | data opt_comma datalist
  156.     ;
  157.  
  158. in_data:
  159.         { if(parstate == OUTSIDE)
  160.             {
  161.             newproc();
  162.             startproc(ESNULL, CLMAIN);
  163.             }
  164.           if(parstate < INDATA)
  165.             {
  166.             enddcl();
  167.             parstate = INDATA;
  168.             }
  169.         }
  170.     ;
  171.  
  172. datalist:  datainit datavarlist SSLASH datapop vallist SSLASH
  173.         { ftnint junk;
  174.           if(nextdata(&junk) != NULL)
  175.             err("too few initializers");
  176.           frdata($2);
  177.           frrpl();
  178.         }
  179.     ;
  180.  
  181. datainit: /* nothing */ { frchain(&datastack); curdtp = 0; }
  182.  
  183. datapop: /* nothing */ { pop_datastack(); }
  184.  
  185. vallist:  { toomanyinit = NO; }  val
  186.     | vallist SCOMMA val
  187.     ;
  188.  
  189. val:      value
  190.         { dataval(ENULL, $1); }
  191.     | simple SSTAR value
  192.         { dataval($1, $3); }
  193.     ;
  194.  
  195. value:      simple
  196.     | addop simple
  197.         { if( $1==OPMINUS && ISCONST($2) )
  198.             consnegop((Constp)$2);
  199.           $$ = $2;
  200.         }
  201.     | complex_const
  202.     ;
  203.  
  204. savelist: saveitem
  205.     | savelist SCOMMA saveitem
  206.     ;
  207.  
  208. saveitem: name
  209.         { int k;
  210.           $1->vsave = YES;
  211.           k = $1->vstg;
  212.         if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) )
  213.             dclerr("can only save static variables", $1);
  214.         }
  215.     | comblock
  216.     ;
  217.  
  218. paramlist:  paramitem
  219.     | paramlist SCOMMA paramitem
  220.     ;
  221.  
  222. paramitem:  name SEQUALS expr
  223.         { if($1->vclass == CLUNKNOWN)
  224.             make_param((struct Paramblock *)$1, $3);
  225.           else dclerr("cannot make into parameter", $1);
  226.         }
  227.     ;
  228.  
  229. var:      name dims
  230.         { if(ndim>0) setbound($1, ndim, dims); }
  231.     ;
  232.  
  233. datavar:      lhs
  234.         { Namep np;
  235.           np = ( (struct Primblock *) $1) -> namep;
  236.           vardcl(np);
  237.           if(np->vstg == STGCOMMON)
  238.             extsymtab[np->vardesc.varno].extinit = YES;
  239.           else if(np->vstg==STGEQUIV)
  240.             eqvclass[np->vardesc.varno].eqvinit = YES;
  241.           else if(np->vstg!=STGINIT && np->vstg!=STGBSS)
  242.             dclerr("inconsistent storage classes", np);
  243.           $$ = mkchain((char *)$1, CHNULL);
  244.         }
  245.     | SLPAR datavarlist SCOMMA dospec SRPAR
  246.         { chainp p; struct Impldoblock *q;
  247.         pop_datastack();
  248.         q = ALLOC(Impldoblock);
  249.         q->tag = TIMPLDO;
  250.         (q->varnp = (Namep) ($4->datap))->vimpldovar = 1;
  251.         p = $4->nextp;
  252.         if(p)  { q->implb = (expptr)(p->datap); p = p->nextp; }
  253.         if(p)  { q->impub = (expptr)(p->datap); p = p->nextp; }
  254.         if(p)  { q->impstep = (expptr)(p->datap); }
  255.         frchain( & ($4) );
  256.         $$ = mkchain((char *)q, CHNULL);
  257.         q->datalist = hookup($2, $$);
  258.         }
  259.     ;
  260.  
  261. datavarlist: datavar
  262.         { if (!datastack)
  263.             curdtp = 0;
  264.           datastack = mkchain((char *)curdtp, datastack);
  265.           curdtp = $1; curdtelt = 0;
  266.           }
  267.     | datavarlist SCOMMA datavar
  268.         { $$ = hookup($1, $3); }
  269.     ;
  270.  
  271. dims:
  272.         { ndim = 0; }
  273.     | SLPAR dimlist SRPAR
  274.     ;
  275.  
  276. dimlist:   { ndim = 0; }   dim
  277.     | dimlist SCOMMA dim
  278.     ;
  279.  
  280. dim:      ubound
  281.         {
  282.           if(ndim == maxdim)
  283.             err("too many dimensions");
  284.           else if(ndim < maxdim)
  285.             { dims[ndim].lb = 0;
  286.               dims[ndim].ub = $1;
  287.             }
  288.           ++ndim;
  289.         }
  290.     | expr SCOLON ubound
  291.         {
  292.           if(ndim == maxdim)
  293.             err("too many dimensions");
  294.           else if(ndim < maxdim)
  295.             { dims[ndim].lb = $1;
  296.               dims[ndim].ub = $3;
  297.             }
  298.           ++ndim;
  299.         }
  300.     ;
  301.  
  302. ubound:      SSTAR
  303.         { $$ = 0; }
  304.     | expr
  305.     ;
  306.  
  307. labellist: label
  308.         { nstars = 1; labarray[0] = $1; }
  309.     | labellist SCOMMA label
  310.         { if(nstars < MAXLABLIST)  labarray[nstars++] = $3; }
  311.     ;
  312.  
  313. label:      SICON
  314.         { $$ = execlab( convci(toklen, token) ); }
  315.     ;
  316.  
  317. implicit:  SIMPLICIT in_dcl implist
  318.         { NO66("IMPLICIT statement"); }
  319.     | implicit SCOMMA implist
  320.     ;
  321.  
  322. implist:  imptype SLPAR letgroups SRPAR
  323.     | imptype
  324.         { if (vartype != TYUNKNOWN)
  325.             dclerr("-- expected letter range",NPNULL);
  326.           setimpl(vartype, varleng, 'a', 'z'); }
  327.     ;
  328.  
  329. imptype:   { needkwd = 1; } type
  330.         /* { vartype = $2; } */
  331.     ;
  332.  
  333. letgroups: letgroup
  334.     | letgroups SCOMMA letgroup
  335.     ;
  336.  
  337. letgroup:  letter
  338.         { setimpl(vartype, varleng, $1, $1); }
  339.     | letter SMINUS letter
  340.         { setimpl(vartype, varleng, $1, $3); }
  341.     ;
  342.  
  343. letter:  SNAME
  344.         { if(toklen!=1 || token[0]<'a' || token[0]>'z')
  345.             {
  346.             dclerr("implicit item must be single letter", NPNULL);
  347.             $$ = 0;
  348.             }
  349.           else $$ = token[0];
  350.         }
  351.     ;
  352.  
  353. namelist:    SNAMELIST
  354.     | namelist namelistentry
  355.     ;
  356.  
  357. namelistentry:  SSLASH name SSLASH namelistlist
  358.         {
  359.         if($2->vclass == CLUNKNOWN)
  360.             {
  361.             $2->vclass = CLNAMELIST;
  362.             $2->vtype = TYINT;
  363.             $2->vstg = STGBSS;
  364.             $2->varxptr.namelist = $4;
  365.             $2->vardesc.varno = ++lastvarno;
  366.             }
  367.         else dclerr("cannot be a namelist name", $2);
  368.         }
  369.     ;
  370.  
  371. namelistlist:  name
  372.         { $$ = mkchain((char *)$1, CHNULL); }
  373.     | namelistlist SCOMMA name
  374.         { $$ = hookup($1, mkchain((char *)$3, CHNULL)); }
  375.     ;
  376.  
  377. in_dcl:
  378.         { switch(parstate)
  379.             {
  380.             case OUTSIDE:    newproc();
  381.                     startproc(ESNULL, CLMAIN);
  382.             case INSIDE:    p